VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsFunctions"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'barb: some arb change  . . . .
Public Function ValidateXmlFormat(strErrMsg As String) As Boolean

    Dim xmldoc As MSXML2.DOMDocument
    Dim strXML As String
    Dim ind
    Dim strTemp As String

    On Error GoTo ValidateXmlFormatFix

    Set xmldoc = New MSXML2.DOMDocument
    strXML = IdxVars.XMLString
    
    'Validation XML Document
    'i.e. load the source XML file into an MSXML DOMDocument object
    xmldoc.async = False
    'If Not XMLDoc.Load("C:\Projects\KeyTax\Xml\XmlDocs\FormB_Request.xml") Then
    
    'for testing without dtd:
    'strXML = Right(strXML, Len(strXML) - 81)
    'IdxVars.XmlString = strXML
    
    strXML = ReplaceTESTRefs(strXML) 'When testing, the reference to the DTDs will be updated
    
    If Not xmldoc.loadXML(strXML) Then
        ind = 0
        ind = xmldoc.parseError.linepos
        
        If xmldoc.parseError.errorCode = -1072898030 Then
            ind = ind + 1
            Do While Trim(strTemp) <> ">"
                strTemp = Mid(xmldoc.parseError.srcText, ind, 1)
                ind = ind + 1
            Loop
            strTemp = Mid(xmldoc.parseError.srcText, ind, (ind) - _
        xmldoc.parseError.linepos)
        Else
            ind = ind - 1
            Do While Trim(strTemp) <> "<" 'And Trim(strTemp) <> ""
                strTemp = Mid(xmldoc.parseError.srcText, ind, 1)
                ind = ind - 1
            Loop
            strTemp = Mid(xmldoc.parseError.srcText, ind + 1, _
            xmldoc.parseError.linepos - (ind + 1))
        End If
    
        xmldoc.validateOnParse = True
        strErrMsg = strErrMsg & "Error Code: " & xmldoc.parseError.errorCode & vbCrLf
        strErrMsg = strErrMsg & "Error Reason: " & xmldoc.parseError.Reason & vbCrLf
        strErrMsg = strErrMsg & "Error Text: " & xmldoc.parseError.srcText & vbCrLf
        strErrMsg = strErrMsg & "Error Line: " & xmldoc.parseError.Line & vbCrLf & "Error occurred after: " & strTemp
        
        
        FileFmtErrVars.Code = Trim(xmldoc.parseError.errorCode)
        FileFmtErrVars.Reason = Trim(xmldoc.parseError.Reason)
        FileFmtErrVars.Text = Trim(xmldoc.parseError.srcText)
        FileFmtErrVars.Line = Trim(xmldoc.parseError.Line) & vbCrLf & "Error occurred near:" & strTemp
                
        ValidateXmlFormat = False
    Else
        ValidateXmlFormat = True
    End If

    Exit Function
    
ValidateXmlFormatFix:
    AddErrorMessage ("ReceiveXml.dll/clsFunctions/ValidateXmlFormat: " & Err.Number & " - " & Err.Description)
    ValidateXmlFormat = False
End Function

Public Function ExtractBlobFromDb() As Boolean


     Dim rsBlob As ADODB.Recordset
     Dim arrBlob() As Byte
     Dim iFree As Integer
     Dim lngBlobLen As Long
     Dim lngRemainder As Long
     Dim lngNumOfSections As Long
     Dim strSql As String
     Dim BlobHolder As Variant
     Dim i As Integer
     Dim strHolder As String

     Const SEGMENT_LENGTH As Long = 4096

    On Error GoTo ExtractBlobFromDbFix
    
     iFree = FreeFile
     'initilize the recordset
     Set rsBlob = New ADODB.Recordset
     rsBlob.CursorType = adOpenKeyset
     rsBlob.LockType = adLockOptimistic
     
    strSql = "Select * from DIR_INTERFACE_INDEX I, DIR_INTERFACE_XML X"
    strSql = strSql & " where I.MQ_STATUS = '01'"
    strSql = strSql & " and I.INTERFACE_NO = X.INTERFACE_NO"
    strSql = strSql & " and I.MESSAGE_ID = X.MESSAGE_ID  ORDER  BY  I.INTERFACE_NO DESC "
    
    Set rsBlob = adoConn.Execute(strSql)
    
    'Check if recordset is empty
    Dim dllRecordsetExist As clsIsRecordsetEmpty
    Set dllRecordsetExist = New clsIsRecordsetEmpty
    Dim blResponseRSEmpty As Boolean
    blResponseRSEmpty = dllRecordsetExist.IsEmpty(rsBlob)
     
    If blResponseRSEmpty = True Then
        ExtractBlobFromDb = False
        Exit Function
    Else
        ExtractBlobFromDb = True
        
        frmPoll.lblFileCount.Caption = "Checking for Files. " & rsBlob.RecordCount & " request(s) remaining"
        frmPoll.Refresh
        DoEvents
            
        ClearIdxVars
     
         rsBlob.MoveFirst
         
        'JohannTesting-------------------------------------------------
'        Dim rsBlobTest, strXML
'
'        strSql = "select xml_string from dir_interface_xml"
'        strSql = strSql & " where interface_no = " & rsBlob!INTERFACE_NO
'        Set rsBlobTest = adoConn.Execute(strSql)
'        strXML = rsBlobTest.fields("xml_string").Value
'        Set rsBlobTest = Nothing
'
'        Debug.Print rsBlob!INTERFACE_NO & vbCrLf & vbCrLf & strXML
        '/JohannTesting------------------------------------------------
         
         'barb: get idx vars here
         IdxVars.InterfaceNo = rsBlob!INTERFACE_NO
         'IdxVars.ReferenceID = rsBlob!REFERENCE_ID
         IdxVars.Tracking.MsgId = rsBlob!MESSAGE_ID
         IdxVars.Tracking.ComId = rsBlob!COM_ID
         IdxVars.Tracking.BuId = rsBlob!BU_ID
         IdxVars.CreatedDated = rsBlob!CREATED_DATE
         IdxVars.MqStatus = "01"
    
         'get the length of the blob
         lngBlobLen = rsBlob!xml_string.ActualSize
    
         'get the number of sections that will be the number of elements in the sections array
         lngNumOfSections = lngBlobLen \ SEGMENT_LENGTH
    
         'get the leftover bytes that aren't divisible by the section_length
         lngRemainder = lngBlobLen Mod SEGMENT_LENGTH
    
         If lngRemainder <> 0 Then 'add the remaider
             'arrBlob = rsBlob(2).GetChunk(lngRemainder)
             arrBlob = rsBlob!xml_string.GetChunk(lngRemainder)
         End If
    
        strHolder = CStr(arrBlob)
    
        'loop for the rest
        For i = 1 To lngNumOfSections
            'arrBlob = rsBlob(0).GetChunk(SEGMENT_LENGTH)
            arrBlob = rsBlob!xml_string.GetChunk(SEGMENT_LENGTH)
            'strTemp = strTemp & CStr(arrBlob(i - 1))
            strHolder = strHolder & CStr(arrBlob)
        Next
    
    '     For i = 0 To UBound(arrBlob)
    '         strHolder = strHolder & Chr(arrBlob(i))
    '     Next
        
        strHolder = ReplaceTESTRefs(strHolder) 'When testing, the reference to the DTDs will be updated
        
        IdxVars.XMLString = strHolder
        
        rsBlob.Close
    End If
    
    Exit Function
    
ExtractBlobFromDbFix:
    ExtractBlobFromDb = False
    AddErrorMessage ("ReceiveXml.dll/clsFunctions/ExtractBlobFromDb: " & Err.Number & " - " & Err.Description)
End Function
Public Function GetHeaderData() As Boolean
    
    '   This function reads the xml string and extracts the values required to update and insert into the
    '   DIR_INTERFACE_INDEX table and puts them into the public IdxVars type
    
    'XML Objects
    Dim xmldoc As MSXML2.DOMDocument
    Dim nlKeytax As MSXML2.IXMLDOMNodeList
    Dim elKeyTax As MSXML2.IXMLDOMElement
    Dim nlTracking As MSXML2.IXMLDOMNodeList
    Dim elTracking As MSXML2.IXMLDOMElement
 
    'Other
    Dim i As Integer
    Dim strErrMsg As String
    Dim strXmlString As String

    On Error GoTo GetHeaderDataFix
    
    Set xmldoc = New MSXML2.DOMDocument
    'Get Data
    
    
    IdxVars.XMLString = ReplaceTESTRefs(IdxVars.XMLString) 'When testing, the reference to the DTDs will be updated
    
    xmldoc.loadXML (IdxVars.XMLString)
    
    Set nlKeytax = xmldoc.selectNodes("/KeyTax")
    Set elKeyTax = nlKeytax.Item(0)
    IdxVars.KeyTaxType = elKeyTax.getAttribute("Type")
    
    
    Set nlTracking = xmldoc.selectNodes("/KeyTax/Requestor/*")

    For i = 0 To nlTracking.length - 1
        Set elTracking = nlTracking.Item(i)
        Select Case elTracking.nodeName
                Case "Date"
                    IdxVars.Request.Date = NullOrValue(nlTracking.Item(i).nodeTypedValue)
                Case "Time"
                    IdxVars.Request.Time = NullOrValue(nlTracking.Item(i).nodeTypedValue)
                Case "Name"
                    IdxVars.Request.Name = NullOrValue(nlTracking.Item(i).nodeTypedValue)
                Case "UserID"
                    IdxVars.Request.UserId = NullOrValue(nlTracking.Item(i).nodeTypedValue)
                Case "email"
                    IdxVars.Request.Email = NullOrValue(nlTracking.Item(i).nodeTypedValue)
                Case "KeytaxRequestNumber"
                    IdxVars.Tracking.ReqSeqNum = NullOrValue(nlTracking.Item(i).nodeTypedValue)
        End Select
    Next i
    
    
    Set nlTracking = xmldoc.selectNodes("/KeyTax/Tracking/*")

    For i = 0 To nlTracking.length - 1
        Set elTracking = nlTracking.Item(i)
        Select Case elTracking.nodeName
                Case "RequestStatus"
                    IdxVars.Tracking.RequestStatus = NullOrValue(nlTracking.Item(i).nodeTypedValue)
                Case "Company"
                    IdxVars.Tracking.ComId = NullOrValue(elTracking.getAttribute("ID"))
                Case "BusinessUnit"
                    IdxVars.Tracking.BuId = NullOrValue(elTracking.getAttribute("ID"))
                Case "Message"
                    IdxVars.Tracking.MsgId = NullOrValue(elTracking.getAttribute("ID"))
                Case "Reference"
                    IdxVars.Tracking.ReferenceID = NullOrValue(elTracking.getAttribute("ID"))
                Case "KeytaxRequestNumber"
                    IdxVars.Tracking.ReqSeqNum = NullOrValue(nlTracking.Item(i).nodeTypedValue)
        End Select
    Next i

    Set nlKeytax = xmldoc.selectNodes("/KeyTax/Directive")
    Set elKeyTax = nlKeytax.Item(0)
    'IdxVars.Form_Request_Type = NullOrValue(elKeyTax.getAttribute("Form"))
    
    

    GetHeaderData = True

Exit Function

GetHeaderDataFix:
    GetHeaderData = False
    AddErrorMessage ("ReceiveXml.dll/clsFunctions/GetHeaderData: " & Err.Number & " - " & Err.Description)
End Function

Private Function NullOrValue(varValue As Variant) As String

    If Not IsNull(varValue) Then
        If Len(Trim(varValue)) <> 0 Then
           NullOrValue = varValue
        Else
            NullOrValue = "NULL"
        End If
    Else
        NullOrValue = "NULL"
    End If

End Function
Public Function ValidateHeaderData(strErr As String) As Boolean
    
    Dim strSql As String
    Dim rsIndex As ADODB.Recordset
    
    Dim i As Integer
    Dim j As Integer
    Dim arBusUnits As Variant
    Dim blnFound As Boolean
    Dim strBusUnit As String
    Dim strFileBusUnit As String
    Dim UserId As String

    On Error GoTo ValidateHeaderDataFix


'     'initilize the recordset
     Set rsIndex = New ADODB.Recordset
     rsIndex.CursorType = adOpenKeyset
     rsIndex.LockType = adLockOptimistic

    '***************Index Vars****************
    'InterfaceNo
    If IdxVars.InterfaceNo = 0 Then
        strErr = strErr & "Invalid Interface number: " & IdxVars.InterfaceNo & vbCrLf
    ElseIf Len(Trim(IdxVars.InterfaceNo)) = 0 Then
        strErr = strErr & "Invalid Interface number: " & IdxVars.InterfaceNo & vbCrLf
    End If
             
    'xml string
    If Len(Trim(IdxVars.XMLString)) = 0 Then
        strErr = strErr & "Invalid XML string: " & IdxVars.XMLString & vbCrLf
    End If
    
    'CreatedDate
    If Len(Trim(IdxVars.CreatedDated)) = 0 Then
        strErr = strErr & "Invalid CreatedDated: " & IdxVars.CreatedDated & vbCrLf
    ElseIf Trim(IdxVars.CreatedDated) = "NULL" Then
        strErr = strErr & "Invalid CreatedDated: " & IdxVars.CreatedDated & vbCrLf
    End If
'    'Doesn't work for "YYYYMMDD"
'    If Not IsDate(IdxVars.CreatedDated) Then
'        strErr = strErr & "Invalid CreatedDated: " & IdxVars.CreatedDated & vbCrLf
'    End If
    
    'IdxVars.SarsResponseYn = ""        'Allowed to be empty
    
    'KeyTaxType (DIR_SYSTEM_CODES.XML_TYPE)
    If Len(Trim(IdxVars.KeyTaxType)) = 0 Then
        strErr = strErr & "Invalid KeyTaxType: " & IdxVars.KeyTaxType & vbCrLf
    ElseIf Trim(IdxVars.KeyTaxType) = "NULL" Then
        strErr = strErr & "Invalid KeyTaxType: " & IdxVars.KeyTaxType & vbCrLf
    Else
        strSql = "select VALUE from DIR_SYSTEM_CODES where CODE = 'XML_TYPE' and VALUE = '" & IdxVars.KeyTaxType & "'"
        Set rsIndex = adoConn.Execute(strSql)
        If rsIndex.RecordCount <= 0 Then
            strErr = strErr & "Invalid KeyTaxType (DIR_SYSTEM_CODES.XML_TYPE): " & IdxVars.KeyTaxType & vbCrLf
        End If
    End If
    
    'MqStatus (DIR_SYSTEM_CODES.MQ_STATUS)
    If Len(Trim(IdxVars.MqStatus)) = 0 Then
        strErr = strErr & "Invalid MqStatus: " & IdxVars.KeyTaxType & vbCrLf
    ElseIf Trim(IdxVars.MqStatus) = "NULL" Then
        strErr = strErr & "Invalid MqStatus: " & IdxVars.KeyTaxType & vbCrLf
    Else
        strSql = "select VALUE from DIR_SYSTEM_CODES where CODE = 'MQ_STATUS' and VALUE = '" & IdxVars.MqStatus & "'"
        Set rsIndex = adoConn.Execute(strSql)
        If rsIndex.RecordCount <= 0 Then
            strErr = strErr & "Invalid MqStatus (DIR_SYSTEM_CODES.MQ_STATUS): " & IdxVars.MqStatus & vbCrLf
        End If
    End If

    '*************Tracking Vars*****************
    'MsgId
    If Len(Trim(IdxVars.Tracking.MsgId)) = 0 Then
        strErr = strErr & "Invalid MsgId: " & IdxVars.Tracking.MsgId & vbCrLf
    ElseIf Trim(IdxVars.Tracking.MsgId) = "NULL" Then
        strErr = strErr & "Invalid MsgId: " & IdxVars.Tracking.MsgId & vbCrLf
    End If
    
    'ComId  (DIR_COMPANIES.COM_ID)
    If Len(Trim(IdxVars.Tracking.ComId)) = 0 Then
        strErr = strErr & "Invalid ComId: " & IdxVars.Tracking.ComId & vbCrLf
    ElseIf Trim(IdxVars.Tracking.ComId) = "NULL" Then
        strErr = strErr & "Invalid ComId: " & IdxVars.Tracking.ComId & vbCrLf
    Else
        strSql = "Select COM_ID from DIR_COMPANIES where COM_ID = '" & IdxVars.Tracking.ComId & "'"
        Set rsIndex = adoConn.Execute(strSql)
        If rsIndex.RecordCount <= 0 Then
            strErr = strErr & "Invalid ComId (DIR_COMPANIES.COM_ID): " & IdxVars.Tracking.ComId & vbCrLf
        End If
    End If
    
    'BusUnit (DIR_BUSINESS_UNITS.CODE)
    If Len(Trim(IdxVars.Tracking.BuId)) = 0 Then
        strErr = strErr & "Invalid BuId: " & IdxVars.Tracking.BuId & vbCrLf
    ElseIf Trim(IdxVars.Tracking.BuId) = "NULL" Then
        strErr = strErr & "Invalid BuId: " & IdxVars.Tracking.BuId & vbCrLf
    Else
        'validate bus unit (LCB also using this field to indicate environment)
        Set rsIndex = New ADODB.Recordset
        rsIndex.CursorType = adOpenKeyset
        rsIndex.LockType = adLockOptimistic
                        
        'strSql = "Select CODE from DIR_BUSINESS_UNITS where COM_ID = '" & IdxVars.Tracking.ComId & "' and CODE = '" & IdxVars.Tracking.BuId & "'"
        strSql = "Select CODE from DIR_BUSINESS_UNITS where COM_ID = '" & IdxVars.Tracking.ComId & "'"
        Set rsIndex = adoConn.Execute(strSql)
        If rsIndex.RecordCount > 0 Then
            arBusUnits = rsIndex.GetRows(rsIndex.RecordCount)
            For i = 0 To UBound(arBusUnits, 2)
                'For j = 1 To Len(Trim(arBusUnits(0, i)))
                For j = 1 To Len(Trim(IdxVars.Tracking.BuId))
                    'strBusUnit = Left(arBusUnits(0, i), j)
                    strFileBusUnit = Left(IdxVars.Tracking.BuId, j)
                    strBusUnit = arBusUnits(0, i)
                    'If IdxVars.Tracking.BuId Like strBusUnit & "*" Then
                    If strFileBusUnit = strBusUnit Then
                        blnFound = True
                        Exit For
                    Else
                        blnFound = False
                    End If
                Next j
                If blnFound = True Then
                    Exit For
                End If
            Next i
            If blnFound = False Then
                strErr = strErr & "Invalid BuId (DIR_BUSINESS_UNITS.CODE): " & IdxVars.Tracking.BuId & vbCrLf
            End If
        Else
            strErr = strErr & "No business units were found in DIR_BUSINESS_UNITS for DIR_BUSINESS_UNITS.COM_ID: " & IdxVars.Tracking.ComId & " (DIR_BUSINESS_UNITS.CODE: " & IdxVars.Tracking.BuId & ")" & vbCrLf
        End If
    End If
    
    'ReferenceId
    If Len(Trim(IdxVars.Tracking.ReferenceID)) = 0 Then
        strErr = strErr & "Invalid ReferenceId: " & IdxVars.Tracking.ReferenceID & vbCrLf
    ElseIf Trim(IdxVars.Tracking.ReferenceID) = "NULL" Then
        strErr = strErr & "Invalid ReferenceId: " & IdxVars.Tracking.ReferenceID & vbCrLf
    End If
    
    'ReqSeqNum (DIR_REQUEST.REQ_SEQ_NUM)
    If Len(Trim(IdxVars.Tracking.ReqSeqNum)) <> 0 Then
        If IdxVars.Tracking.ReqSeqNum <> "NULL" Then
            strSql = "Select REQ_SEQ_NUM from DIR_REQUEST where REQ_SEQ_NUM = " & IdxVars.Tracking.ReqSeqNum
            Set rsIndex = adoConn.Execute(strSql)
            If rsIndex.RecordCount <= 0 Then
                strErr = strErr & "Invalid ReqSeqNum (DIR_REQUEST.REQ_SEQ_NUM): " & IdxVars.Tracking.ReqSeqNum & vbCrLf
            End If
        End If
    End If
    
    'RequestStatus  (DIR_SYSTEM_CODES.DIR_REQ_STATUS)
'    If Len(Trim(IdxVars.Tracking.RequestStatus)) = 0 Then
'        strErr = strErr & "Invalid RequestStatus: " & IdxVars.Tracking.RequestStatus & vbCrLf
'        'can be null at this stage, it's up to you to put in from the xml file??
'    ElseIf Trim(IdxVars.Tracking.RequestStatus) = "NULL" Then
'        strErr = strErr & "Invalid RequestStatus: " & IdxVars.Tracking.RequestStatus & vbCrLf
'    Else
'        strSql = "Select MEANING from DIR_SYSTEM_CODES where CODE = 'DIR_REQ_STATUS' and VALUE = '" & IdxVars.Tracking.RequestStatus & "'"
'        Set rsIndex = adoConn.Execute(strSql)
'        If rsIndex.RecordCount <= 0 Then
'
'            strSql = "Select MEANING from DIR_SYSTEM_CODES where CODE = 'DIR_REQ_STATUS' and MEANING = '" & IdxVars.Tracking.RequestStatus & "'"
'            Set rsIndex = adoConn.Execute(strSql)
'            If rsIndex.RecordCount <= 0 Then
'                strErr = strErr & "Invalid RequestStatus (DIR_SYSTEM_CODES.DIR_REQ_STATUS): " & IdxVars.Tracking.RequestStatus & vbCrLf
'            End If
'        End If
'    End If
    '****************Requestor Vars*********************
    'Date
    If Len(Trim(IdxVars.Request.Date)) = 0 Then
        strErr = strErr & "Invalid Date: " & IdxVars.Request.Date & vbCrLf
    ElseIf Trim(IdxVars.Request.Date) = "NULL" Then
        strErr = strErr & "Invalid Date: " & IdxVars.Request.Date & vbCrLf
    ElseIf Len(Trim(IdxVars.Request.Date)) <> 8 Then
        strErr = strErr & "Invalid Date: " & IdxVars.Request.Date & vbCrLf
    End If
'    If Not IsDate(IdxVars.Request.Date) Then
'        strErr = strErr & "Invalid Date: " & IdxVars.Request.Date & vbCrLf
'    End If
    
    'Email
    If Len(Trim(IdxVars.Request.Email)) = 0 Then
        strErr = strErr & "Invalid Email: " & IdxVars.Request.Email & vbCrLf
    ElseIf Trim(IdxVars.Request.Email) = "NULL" Then
        strErr = strErr & "Invalid Email: " & IdxVars.Request.Email & vbCrLf
    ElseIf InStr(1, IdxVars.Request.Email, "@") = 0 Then
        strErr = strErr & "Invalid Email: " & IdxVars.Request.Email & vbCrLf
    End If
    
    'Name
    If Len(Trim(IdxVars.Request.Name)) = 0 Then
        strErr = strErr & "Invalid Name: " & IdxVars.Request.Name & vbCrLf
    ElseIf Trim(IdxVars.Request.Name) = "NULL" Then
        strErr = strErr & "Invalid Name: " & IdxVars.Request.Name & vbCrLf
    End If
    
    'Time
    If Len(Trim(IdxVars.Request.Time)) = 0 Then
        strErr = strErr & "Invalid Time: " & IdxVars.Request.Time & vbCrLf
    ElseIf Trim(IdxVars.Request.Time) = "NULL" Then
        strErr = strErr & "Invalid Time: " & IdxVars.Request.Time & vbCrLf
    ElseIf Len(Trim(IdxVars.Request.Time)) <> 6 Then
        strErr = strErr & "Invalid Time: " & IdxVars.Request.Time & vbCrLf
    End If
    
    'UserId
    If Len(Trim(IdxVars.Request.UserId)) = 0 Then
        strErr = strErr & "Invalid UserId: " & IdxVars.Request.UserId & vbCrLf
    ElseIf Trim(IdxVars.Request.UserId) = "NULL" Then
        strErr = strErr & "Invalid UserId: " & IdxVars.Request.UserId & vbCrLf
    ElseIf Not ValidateUser(IdxVars.Request.UserId) = True Then
        strErr = strErr & "Invalid UserId: " & IdxVars.Request.UserId & vbCrLf
    End If
    
    'Request Sequence Number
    If IdxVars.KeyTaxType = "03" Or IdxVars.KeyTaxType = "07" Or IdxVars.KeyTaxType = "08" Then
        If Len(Trim(IdxVars.Tracking.ReqSeqNum)) = 0 Then
            strErr = strErr & "Invalid Request Sequence Number: Request Sequence Number was not provided " & vbCrLf
        ElseIf Trim(IdxVars.Tracking.ReqSeqNum) = "NULL" Then
            strErr = strErr & "Invalid Request Sequence Number: Request Sequence Number was not provided " & vbCrLf
        End If
    End If
    
    If Len(Trim(strErr)) = 0 Then
        ValidateHeaderData = True
    Else
        ValidateHeaderData = False
    End If
    
    Exit Function
    
ValidateHeaderDataFix:
    ValidateHeaderData = False
    AddErrorMessage ("ReceiveXml.dll/clsFunctions/ValidateHeaderData: " & Err.Number & " - " & Err.Description)
End Function
Public Function UpdateInterfaceIndex() As Boolean

    'Db vars
    Dim strSql As String
    Dim cmdAdo As ADODB.Command
    Dim lngRecordsAffected As Long
    Dim rsIndex As ADODB.Recordset

    On Error GoTo UpdateInterfaceIndexFix


'     'initilize the recordset
     Set rsIndex = New ADODB.Recordset
     rsIndex.CursorType = adOpenKeyset
     rsIndex.LockType = adLockOptimistic
     
     
'    strSql = "Select * from DIR_INTERFACE_INDEX"
    'strSql = "Select * from DIR_INTERFACE_INDEX"
    'strSql = "Select XML_STRING from DIR_INTERFACE_INDEX I, DIR_INTERFACE_XML X"
    strSql = "Select * from DIR_INTERFACE_INDEX"
    strSql = strSql & " where INTERFACE_NO = " & CLng(IdxVars.InterfaceNo)
    Set rsIndex = adoConn.Execute(strSql)
    
    'Check if recordset is empty
    Dim dllRecordsetExist As clsIsRecordsetEmpty
    Set dllRecordsetExist = New clsIsRecordsetEmpty
    Dim blResponseRSEmpty As Boolean
    blResponseRSEmpty = dllRecordsetExist.IsEmpty(rsIndex)
     
    If blResponseRSEmpty = True Then
        UpdateInterfaceIndex = False
        Exit Function
    Else
        If rsIndex.RecordCount = 1 Then
            strSql = "Update DIR_INTERFACE_INDEX"
            'these should already have been inserted by Johan
            'strSql = strSql & " set COM_ID = '" & IdxVars.Tracking.ComId & "'"
            'strSql = strSql & ", BU_ID = '" & IdxVars.Tracking.BuId & "'"
            'strSql = strSql & ", MESSAGE_ID = '" & IdxVars.Tracking.MsgId & "'"
            strSql = strSql & " set REFERENCE_ID = '" & IdxVars.Tracking.ReferenceID & "'"
            If IdxVars.Tracking.ReqSeqNum <> "NULL" Then
                If IdxVars.Tracking.ReqSeqNum <> "" Then
                    strSql = strSql & ", REQ_SEQ_NUM = " & IdxVars.Tracking.ReqSeqNum
                End If
            End If
            'strSql = strSql & ", CREATED_DATE = '" & IdxVars.ComId & "'"
            strSql = strSql & ", KEYTAX_TYPE = '" & IdxVars.KeyTaxType & "'"
            'strSql = strSql & ", MQ_STATUS = '" & IdxVars.MqStatus & "'"
            strSql = strSql & ", MQ_STATUS = '04'"  'Processed
            strSql = strSql & " where INTERFACE_NO = " & CLng(IdxVars.InterfaceNo)
            
            Set cmdAdo = New ADODB.Command
            With cmdAdo
                .CommandText = strSql
                .CommandType = adCmdText
                Set .ActiveConnection = adoConn
                .Execute lngRecordsAffected
            End With
            If lngRecordsAffected = 1 Then
                UpdateInterfaceIndex = True
            Else
                UpdateInterfaceIndex = False
            End If
        Else
            UpdateInterfaceIndex = False
        End If
    End If
    
    Exit Function

UpdateInterfaceIndexFix:
    UpdateInterfaceIndex = False
    AddErrorMessage ("ReceiveXml.dll/clsFunctions/UpdateInterfaceIndex: " & Err.Number & " - " & Err.Description)
End Function
Public Function PassToDll(strErrMsg As String) As Boolean
    
    'Db vars
    Dim rsIndex As ADODB.Recordset
    Dim strSql As String
    Dim lngRecordsAffected As Long
    
    'Dll vars
    Dim strObjectName As Object
    Dim strProgram As String
    Dim strClass As String
    Dim strFunction As String
    Dim strDataErrMessage As String
    Dim strDllErrMsg As String
    
    
    Dim arParams(2) As String
    
    On Error GoTo PassToDllFix
        
'    XML_TYPE,01,Directive Request
'    XML_TYPE,02,Directive Response
'    XML_TYPE,03,Cancel Directive Request
'    XML_TYPE,04,Cancel Directive Response
'    XML_TYPE,05,Decline Response
'    XML_TYPE,06,File Approved Response
'    XML_TYPE,07,Resend Directive Request
'    XML_TYPE,08,Status Enquiry Request
'    XML_TYPE,09,Status Response
'    XML_TYPE,10,File Error Response
          
    Set rsIndex = New ADODB.Recordset
    With rsIndex
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
    End With
    
    strSql = "Select PROGRAM_NAME, PUBLIC_CLASS_NAME, PUBLIC_FUNCTION_NAME from DIR_INTERFACE_MODULES"
    strSql = strSql & " where XML_TYPE = '" & IdxVars.KeyTaxType & "'"
    strSql = strSql & " and PUBLIC_CLASS_NAME is not null"
    strSql = strSql & " and PUBLIC_FUNCTION_NAME is not null"
    'strSql = strSql & " and FORM_REQUEST_TYPE = '" & IdxVars.KeyTaxType & "'"
        
    Set rsIndex = adoConn.Execute(strSql)
    
    'Check if recordset is empty
    Dim dllRecordsetExist As clsIsRecordsetEmpty
    Set dllRecordsetExist = New clsIsRecordsetEmpty
    Dim blResponseRSEmpty As Boolean
    blResponseRSEmpty = dllRecordsetExist.IsEmpty(rsIndex)
     
    If blResponseRSEmpty = True Then
        PassToDll = False
        Exit Function
    Else
        If rsIndex.RecordCount > 0 Then
            strProgram = Replace(rsIndex!PROGRAM_NAME, vbCrLf, "")
            strClass = Replace(rsIndex!PUBLIC_CLASS_NAME, vbCrLf, "")
            strFunction = Replace(rsIndex!PUBLIC_FUNCTION_NAME, vbCrLf, "")
        
            Set strObjectName = Nothing
    
            'create an instance of the dll
            Set strObjectName = CreateObject(CStr(strProgram & "." & strClass))
            
                    
            'get the parameters to send to the dll in an array
            arParams(0) = IdxVars.InterfaceNo
            arParams(1) = IdxVars.Request.UserId
            arParams(2) = IdxVars.Request.Email
            
            'call the DLL's method
            Dim dllProcessStart As Object
            Dim blProcessComplete As Boolean
            Dim blFunctionCompleted As Boolean
            
            If strProgram = "CancelDirective" Then
                blFunctionCompleted = CallByName(strObjectName, strFunction, VbMethod, arParams, strDllErrMsg)
            Else
                blFunctionCompleted = CallByName(strObjectName, strFunction, VbMethod, arParams, strDllErrMsg, strDataErrMessage)
            End If
            
            If blFunctionCompleted Then
                    PassToDll = True
                Else
                    If strDllErrMsg <> "" Then
                        strErrMsg = strProgram & "." & strClass & ": " & strDllErrMsg
                    ElseIf strDataErrMessage <> "" Then
                        strErrMsg = strProgram & "." & strClass & ": " & strDataErrMessage
                    End If
                    PassToDll = False
                End If
            Else
                AddErrorMessage ("Interface Modules are not set up in the database.")
                End
            End If
    End If
    
    Exit Function
    
PassToDllFix:
    PassToDll = False
    AddErrorMessage ("ReceiveXml.dll/clsFunctions/PassToDll: " & Err.Number & " - " & Err.Description)
End Function
Public Function IndicateError() As Boolean

    'Db vars
    Dim strSql As String
    Dim cmdAdo As ADODB.Command
    Dim lngRecordsAffected As Long
    Dim rsIndex As ADODB.Recordset

    On Error GoTo IndicateErrorFix


'     'initilize the recordset
     Set rsIndex = New ADODB.Recordset
     rsIndex.CursorType = adOpenKeyset
     rsIndex.LockType = adLockOptimistic
     
    strSql = "Select * from DIR_INTERFACE_INDEX"
    strSql = strSql & " where INTERFACE_NO = " & CLng(IdxVars.InterfaceNo)
    Set rsIndex = adoConn.Execute(strSql)
    
    'Check if recordset is empty
    Dim dllRecordsetExist As clsIsRecordsetEmpty
    Set dllRecordsetExist = New clsIsRecordsetEmpty
    Dim blResponseRSEmpty As Boolean
    blResponseRSEmpty = dllRecordsetExist.IsEmpty(rsIndex)
     
    If blResponseRSEmpty = True Then
        IndicateError = False
        Exit Function
    Else
        If rsIndex.RecordCount = 1 Then
            strSql = "Update DIR_INTERFACE_INDEX"
            strSql = strSql & " set REFERENCE_ID = '" & IdxVars.Tracking.ReferenceID & "'"
            If IdxVars.Tracking.ReqSeqNum <> "NULL" Then
                If IdxVars.Tracking.ReqSeqNum <> "" Then
                    strSql = strSql & ", REQ_SEQ_NUM = " & IdxVars.Tracking.ReqSeqNum
                End If
            End If
            strSql = strSql & ", KEYTAX_TYPE = '" & IdxVars.KeyTaxType & "'"
            strSql = strSql & ", MQ_STATUS = '06'"  'Error
            strSql = strSql & " where INTERFACE_NO = " & CLng(IdxVars.InterfaceNo)
            
            Set cmdAdo = New ADODB.Command
            With cmdAdo
                .CommandText = strSql
                .CommandType = adCmdText
                Set .ActiveConnection = adoConn
                .Execute lngRecordsAffected
            End With
            If lngRecordsAffected = 1 Then
                IndicateError = True
            Else
                IndicateError = False
            End If
        Else
            IndicateError = False
        End If
    End If
    
    Exit Function

IndicateErrorFix:
    IndicateError = False
    AddErrorMessage ("ReceiveXml.dll/clsFunctions/IndicateError: " & Err.Number & " - " & Err.Description)
End Function
Public Function CreateXmlHeader() As String
    
    Dim xmldoc As MSXML2.DOMDocument
     
    Dim nNode As MSXML2.IXMLDOMNode
    Dim nChild As MSXML2.IXMLDOMNode
    Dim nParentList As MSXML2.IXMLDOMNodeList
    Dim nParentFoundList As MSXML2.IXMLDOMNodeList
    Dim nParent As MSXML2.IXMLDOMNode
    Dim eParent As MSXML2.IXMLDOMElement
    Dim eChild As MSXML2.IXMLDOMElement
     
    On Error GoTo WriteXmlStringFix
    
    Set xmldoc = New MSXML2.DOMDocument
    
    Set nNode = xmldoc.createNode(NODE_ELEMENT, "KeyTax", "")
    Set xmldoc.documentElement = nNode
     
    Set nParentList = xmldoc.getElementsByTagName("KeyTax")
     
    Set eParent = nParentList.Item(0)
    Call eParent.setAttribute("Type", "10")     '10 = File Error Response
     
    'KeyTax node
    'Add 2 children nodes to the parent KeyTax
    Set eParent = nParentList.Item(0)
    Set eChild = xmldoc.createElement("Requestor")
    Call eParent.appendChild(eChild)
    Set eChild = xmldoc.createElement("Tracking")
    Call eParent.appendChild(eChild)
     
    'MsgBox xmldoc.xml
     
    'Requestor node
    'Set nParentList = xmldoc.selectNodes("/KeyTax/Requestor/*")
    Set nParentList = xmldoc.getElementsByTagName("Requestor")
    Set eParent = nParentList.Item(0)
    Set eChild = xmldoc.createElement("Date")
    eChild.Text = IdxVars.Request.Date
    'Call eChild.setAttribute("Name", "Name Value")
    Call eParent.appendChild(eChild)
    Set eChild = xmldoc.createElement("Time")
    eChild.Text = IdxVars.Request.Time
    Call eParent.appendChild(eChild)
    Set eChild = xmldoc.createElement("Name")
    eChild.Text = IdxVars.Request.Name
    Call eParent.appendChild(eChild)
    Set eChild = xmldoc.createElement("UserID")
    eChild.Text = IdxVars.Request.UserId
    Call eParent.appendChild(eChild)
    Set eChild = xmldoc.createElement("email")
    eChild.Text = IdxVars.Request.Email
    Call eParent.appendChild(eChild)
     
     
    'MsgBox xmldoc.xml
     
    'Tracking node
    'Set nParentList = xmldoc.selectNodes("/KeyTax/Requestor/*")
    Set nParentList = xmldoc.getElementsByTagName("Tracking")
    Set eParent = nParentList.Item(0)
    Set eChild = xmldoc.createElement("RequestStatus")
    eChild.Text = IdxVars.Tracking.RequestStatus
    'Call eChild.setAttribute("Name", "Name Value")
    Call eParent.appendChild(eChild)
    Set eChild = xmldoc.createElement("Company")
    eChild.Text = IdxVars.Tracking.ComId
    Call eParent.appendChild(eChild)
    Set eChild = xmldoc.createElement("BusinessUnit")
    eChild.Text = IdxVars.Tracking.BuId
    Call eParent.appendChild(eChild)
    Set eChild = xmldoc.createElement("Message")
    eChild.Text = IdxVars.Tracking.MsgId
    Call eParent.appendChild(eChild)
    Set eChild = xmldoc.createElement("Reference")
    eChild.Text = IdxVars.Tracking.ReferenceID
    Call eParent.appendChild(eChild)
    Set eChild = xmldoc.createElement("KeytaxRequestNumber")
    eChild.Text = IdxVars.Tracking.ReqSeqNum
    Call eParent.appendChild(eChild)
     
    AddErrorMessage (xmldoc.xml)
    
    CreateXmlHeader = CStr(xmldoc.xml)
    
    Exit Function
    
WriteXmlStringFix:
    AddErrorMessage ("ReceiveXml.dll/clsFunctions/CreateXmlHeader: " & Err.Number & " - " & Err.Description)
End Function
Public Function CreateFileError(strXmlHeader As String, strErrMsg As String, strXmlError As String) As Boolean
    
    Dim xmldoc As MSXML2.DOMDocument
    Dim nlNodeList As MSXML2.IXMLDOMNodeList
    Dim elParent As MSXML2.IXMLDOMElement
    Dim elChild As MSXML2.IXMLDOMElement
    Dim nNode As MSXML2.IXMLDOMNode
 
    'Other
    Dim i As Integer
    Dim strXmlString As String

    
    Dim nParentFoundList As MSXML2.IXMLDOMNodeList

    On Error GoTo CreateFileErrorFix
    
    Set xmldoc = New MSXML2.DOMDocument
    'Get Data
    'XMLDoc.Load ("C:\Shane\Projects\LCB\FormB\FormB_Request.xml")
    xmldoc.loadXML (strXmlHeader)
    Set nNode = xmldoc.selectSingleNode("KeyTax")
    'Set nNode = xmldoc.createNode(NODE_ELEMENT, "KeyTax", "")
    Set xmldoc.documentElement = nNode

'    Set nlNodeList = xmldoc.selectNodes("/KeyTax")
'    Set elKeyTax = nlNodeList.Item(0)
    
    'Add ErrorList Element to KeyTax Node
    Set nlNodeList = xmldoc.getElementsByTagName("KeyTax")
    Set elParent = nlNodeList.Item(0)
    Set elChild = xmldoc.createElement("ErrorList")
    'elError.Text = IdxVars.Request.Date
    Call elChild.setAttribute("Type", 15)               '15 = KeyTax Process Status = Error File Response
    Call elParent.appendChild(elChild)

    'Add Error to ErrorList
    Set nlNodeList = xmldoc.getElementsByTagName("ErrorList")
    Set elParent = nlNodeList.Item(0)
    
    Set elChild = xmldoc.createElement("Error")
    Call elChild.setAttribute("Type", "01")             '01 = Error Type = File Format Error
    Call elParent.appendChild(elChild)
    
    Set nlNodeList = xmldoc.getElementsByTagName("Error")
    Set elParent = nlNodeList.Item(0)
    Set elChild = xmldoc.createElement("Code")
    elChild.Text = FileFmtErrVars.Code
    Call elParent.appendChild(elChild)
    Set elChild = xmldoc.createElement("Reason")
    elChild.Text = FileFmtErrVars.Reason
    Call elParent.appendChild(elChild)
    Set elChild = xmldoc.createElement("Text")
    elChild.Text = FileFmtErrVars.Text
    Call elParent.appendChild(elChild)
    Set elChild = xmldoc.createElement("Line")
    elChild.Text = FileFmtErrVars.Line
    Call elParent.appendChild(elChild)
    
    
    strXmlError = CStr(xmldoc.xml)
    
    AddErrorMessage (xmldoc.xml)

    CreateFileError = True
    Exit Function

    
CreateFileErrorFix:
    CreateFileError = False
    AddErrorMessage ("ReceiveXml.dll/clsFunctions/CreateFileError: " & Err.Number & " - " & Err.Description)
End Function
Private Sub ClearIdxVars()

    IdxVars.InterfaceNo = 0
    IdxVars.XMLString = ""
    IdxVars.CreatedDated = ""
    IdxVars.SarsResponseYn = ""
    IdxVars.KeyTaxType = ""
    IdxVars.MqStatus = ""

    'Tracking Vars
    IdxVars.Tracking.MsgId = ""
    IdxVars.Tracking.ComId = ""
    IdxVars.Tracking.BuId = ""
    IdxVars.Tracking.ReferenceID = ""
    IdxVars.Tracking.ReqSeqNum = ""
    IdxVars.Tracking.RequestStatus = ""
    
    'Requestor Vars
    IdxVars.Request.Date = ""
    IdxVars.Request.Email = ""
    IdxVars.Request.Name = ""
    IdxVars.Request.Time = ""
    IdxVars.Request.UserId = ""
    
    'File Format Error Vars
    FileFmtErrVars.Code = ""
    FileFmtErrVars.Line = ""
    FileFmtErrVars.Reason = ""
    FileFmtErrVars.Text = ""

End Sub
Public Function FileApproved() As Boolean

Dim dllFileApproved As Object
Dim strErrMsg  As String

On Error GoTo PROC_ERROR

Set dllFileApproved = CreateObject("FileApprove.clsFileApprove")
FileApproved = dllFileApproved.CreateApproveFile(IdxVars.InterfaceNo, strErrMsg)

PROC_EXIT:
  Exit Function

PROC_ERROR:
    FileApproved = False
AddErrorMessage ("ReceiveXml.dll/clsFunctions/FileApproved: " & Err.Number & " - " & Err.Description)

Resume PROC_EXIT

End Function

Public Function ValidateUser(ByVal UserId As String) As Boolean

Dim adoConn As ADODB.Connection
Dim rsUsers As ADODB.Recordset
Dim adoComm As ADODB.Command
Dim strConnString As String
Dim strSql As String
Dim nCount As String


On Error GoTo PROC_ERROR

strSql = "select count(*) users From dir_users where upper(username) = upper('" & UserId & "') and authorised_yn = 'Y'"
    
Set adoConn = New ADODB.Connection
With adoConn
    .CursorLocation = adUseClient
    .ConnectionString = GetConnectionString() 'Johann (20090625): Centralised code for connection string added
    .open
End With

Set rsUsers = New ADODB.Recordset
With rsUsers
    .CursorLocation = adUseClient
    .CursorType = adOpenStatic
End With

Set adoComm = New ADODB.Command
With adoComm
    .CommandText = strSql
    .CommandType = adCmdText
    Set .ActiveConnection = adoConn
End With

Set rsUsers = adoComm.Execute

'Check if recordset is empty
    Dim dllRecordsetExist As clsIsRecordsetEmpty
    Set dllRecordsetExist = New clsIsRecordsetEmpty
    Dim blResponseRSEmpty As Boolean
    blResponseRSEmpty = dllRecordsetExist.IsEmpty(rsUsers)
     
    If blResponseRSEmpty = True Then
        ValidateUser = False
        Exit Function
    Else
        nCount = rsUsers.fields("users").Value
        
        If nCount <> 1 Then
            ValidateUser = False
        Else
            ValidateUser = True
        End If
    End If
    
'Clean Up
rsUsers.Close
Set rsUsers = Nothing
Set adoComm = Nothing

PROC_EXIT:
  Exit Function

PROC_ERROR:
    ValidateUser = False
    AddErrorMessage ("ReceiveXml.dll/clsFunctions/ValidateUser: " & Err.Number & " - " & Err.Description)
    
    Resume PROC_EXIT
End Function





